( load segment )

struct
  cell% field segment>number
  cell% field segment>here
  cell% field segment>entry
  cell% field segment>reloc
  cell% field segment>data
  cell% field segment>kind
end-struct segment%

$00000000 constant global-segment
variable next-segment $01000000 next-segment !
variable current-segment

: new-segment-number ( -- n )
  next-segment @ dup $01000000 + next-segment ! ;

$100 constant page
$10000 constant bank
#143360 constant 5.25floppy
#819200 constant 3.5floppy

: new-segment ( kind size -- segment )
  segment% %alloc swap
  allocate throw over segment>data !
  0 over segment>here !
  0 over segment>reloc !
  new-segment-number over segment>number !
  tuck segment>kind ! ;

: switch-segment ( segment -- )
  current-segment ! ;

: ta>segment $ff000000 and ;
: ta>offset  $00ffffff and ;

: same-segment? ( ta1 ta2 -- )
  ta>segment swap ta>segment = ;
: global? ( ta -- )
  ta>segment global-segment = ;

( memory access )

: there  current-segment @ dup segment>number @ swap segment>here @ or ;
: tallot current-segment @ segment>here +! ;
: segment-target ( ta segment -- a )
  over ta>segment over segment>number @ <> abort" address not in segment"
  swap ta>offset swap segment>data @ + ;
: target ( ta -- a )
  current-segment @ segment-target ;
: torg ( ta -- )
  dup ta>segment dup
  current-segment @ segment>number @ <> swap 0<> and abort" address not in current segment"
  ta>offset current-segment @ segment>here ! ;

2 constant tcell
: tcells tcell * ;
: tcell+ tcell + ;

: t1@ ( ta -- c ) target c@ ;
: t1! ( c ta -- ) target c! ;

: t2@ ( ta -- x ) target dup c@ swap 1 + c@ 8 << or ;
: t2! ( x ta -- ) target 2dup c! swap $8 >> swap 1 + c! ;

: t3@ ( ta -- x ) target dup c@ over 1 + c@ $8 << or swap 2 + c@ $10 << or ;
: t3! ( x ta -- ) target 2dup c! over $8 >> over 1 + c! swap $10 >> swap 2 + c! ;

: t4@ ( ta -- x ) target dup c@ over 1 + c@ $8 << or over 2 + c@ $10 << or swap 3 + c@ $18 << or ;
: t4! ( x ta -- ) target 2dup c! over $8 >> over 1 + c! over $10 >> over 2 + c! swap $18 >> swap 3 + c! ;

: t1, there t1! 1 tallot ;
: t2, there t2! 2 tallot ;
: t3, there t3! 3 tallot ;
: t4, there t4! 4 tallot ;

: ts' ( ca n -- ) 0 ?do dup c@ t1, char+ loop drop ;
: ts, ( ca n -- ) dup t1, ts' ;
: ts0, ( ca n -- ) ts' $00 t1, ;

: gsin, ( ca n -- ) dup t2, ts' ;

: $s, ( ca n -- )
  base @ >r #16 base !
  2/ 0 ?do
    dup $2 s>unumber? if
      drop t1,
    else
      true abort" not a hex string"
    then
    $2 +
  loop drop
  r> base ! ;

: tfill ( ta n c -- )
  rot target -rot fill ;

: tfill, ( n c -- )
  swap $0 ?do dup t1, loop drop ;

: entry there current-segment @ segment>entry ! ;

( relocation record )

struct
  cell% field reloc>next
  cell% field reloc>source
  cell% field reloc>destination
  cell% field reloc>length
  cell% field reloc>shift
end-struct reloc%

: reloc-add ( reloc -- )
  current-segment @ segment>reloc dup @ if
    begin
      @ reloc>next dup @ 0=
    until
  then ! ;

: new-reloc ( src dest len shift -- )
  reloc% %alloc >r
  r@ reloc>shift !
  r@ reloc>length !
  r@ reloc>destination !
  r@ reloc>source !
  0 r@ reloc>next !
  r> reloc-add ;

: reloc-iter ( xt segment -- )
  segment>reloc
  begin
    @ dup
  while
    2dup swap execute
  repeat 2drop ;

: rel2l ( src dest -- ) 2  $00 new-reloc ;
: rel2h ( src dest -- ) 2 -$10 new-reloc ;

: a2, ( dest -- ) dup global? 0= if there over 2 0 new-reloc then ta>offset t2, ;
: a3, ( dest -- ) dup global? 0= if there over 3 0 new-reloc then ta>offset t3, ;
: a4, ( dest -- ) dup global? 0= if there over 4 0 new-reloc then ta>offset t4, ;

: a2! ( x a -- ) over global? 0= if 2dup swap 2 0 new-reloc then swap ta>offset swap t2! ;
: a3! ( x a -- ) over global? 0= if 2dup swap 3 0 new-reloc then swap ta>offset swap t3! ;
: a4! ( x a -- ) over global? 0= if 2dup swap 4 0 new-reloc then swap ta>offset swap t4! ;

: write-segment ( fileid segment -- )
  dup segment>data @ swap segment>here @ rot write-file throw ;

\ copy data from another segment
: copy-range ( start length segment -- )
  rot swap segment-target
  swap ts' ;

\ copy data from host file
: copy-host ( ca n -- )
  slurp-file ts' ;

( omf )

$0000 constant kind-code
$0001 constant kind-data
$0002 constant kind-jump
$0004 constant kind-path
$0008 constant kind-lib
$0010 constant kind-init
$0012 constant kind-direct

$0100 constant kind-relative
$0200 constant kind-skip
$0400 constant kind-reload
$0800 constant kind-absolute
$1000 constant kind-nospecial
$2000 constant kind-independent
$4000 constant kind-private
$8000 constant kind-dynamic

kind-code constant code-segment
kind-data constant data-segment
kind-code kind-private or constant cdev-segment

variable segment-start
: omf-segment-start ( ca n segment -- )
  there segment-start !  \ save header position
  $00000000       t4,    \ bytecnt
  $00000000       t4,    \ resspc
  dup segment>here @ t4, \ length
  $00             t1,    \ undefined
  $00             t1,    \ lablen
  $04             t1,    \ numlen
  $02             t1,    \ version
  bank            t4,    \ banksize
  dup segment>kind @ t2, \ kind
  $0000           t2,    \ undefined
  $00000000       t4,    \ org
  $00000000       t4,    \ align
  $00             t1,    \ numsex
  $00             t1,    \ undefined
  dup segment>number @ $18 >> t2,   \ segnum
  dup segment>entry @ ta>offset t4, \ entry
  $002c           t2,    \ dispname
  over $0037 +    t2,    \ dispdata
  $a $0 do $20 t1, loop  \ loadname
  drop ts, ;             \ segname

: lconst ( ca n -- )
  $f2 t1,
  dup t4,
  ts' ;

: omf-lconst ( segment -- )
  dup segment>data @
  swap segment>here @
  lconst ;

: reloc ( reloc -- )
  $e2 t1,
  dup reloc>length @ t1,
  dup reloc>shift @ t1,
  dup reloc>source @ ta>offset t4,
      reloc>destination @ ta>offset t4, ;

: interseg ( reloc -- )
  $e3 t1,
  dup reloc>length @ t1,
  dup reloc>shift @ t1,
  dup reloc>source @ ta>offset t4,
  $0001 t2,
  dup reloc>destination @ ta>segment $18 >> t2,
      reloc>destination @ ta>offset t4, ;

: ref ( reloc -- )
  dup  reloc>source @ ta>segment
  over reloc>destination @ ta>segment =
  if reloc else interseg then ;

: relocs ( segment -- )
  [ ' ref ] literal swap reloc-iter ;

: omf-segment-end ( -- )
  $00 t1,
  there
  segment-start @
  2dup -
  swap torg t4,
  torg ;

: h. $0 <# # # # # # # # # #> type ;
: w. $0 <# # # # # #> type ;
: c. $0 <# # # #> type ;

: print-segment-info ( ca n segment -- ) cr
  cr ." segment:  " -rot type
  cr ."   number: " dup segment>number @ $18 >> c.
  cr ."   size:   "     segment>here @ h. ;

: omf-write-segment ( ca n segment -- )
  >r
  2dup r@ print-segment-info
  r@ omf-segment-start
  r@ omf-lconst
  r> relocs
     omf-segment-end ;

